home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
clue.lha
/
clue
/
events.l
< prev
next >
Wrap
Text File
|
1989-07-12
|
69KB
|
1,802 lines
;;; -*- Mode:Lisp; Package:CLUEI; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
#| To Do:
1. Hooks are in place to handle button mult-click and hold using 3 extra modifier state bits
(:hold :click :double), but the interface isn't there yet.
2. Add translation from symbolic mouse button names to actual mouse button/modifier specs.
Use the keysym translation facilities (define 5 keysyms for each of the mouse keys,
and use define-keysym)
|#
(in-package 'cluei :use '(lisp xlib))
(export '( event
;; Event slots
key display contact character keysym above-sibling
atom border-width child code colormap configure-p count data
drawable event-window focus-p format height hint-p installed-p
keymap kind major minor mode name new-p override-redirect-p
parent place property requestor root root-x root-y same-screen-p
selection send-event-p state target time type width window x y
mode-type
*remap-events*
*restrict-events*
add-mode
delete-mode
with-mode
with-event-mode
contact-mode
contact-super-mode
apply-action
call-action
defaction
describe-action
eval-action
ignore-action
inside-contact-p
perform-callback
throw-action
trace-action
with-event
add-before-action
delete-before-action
process-all-events
process-next-event
handle-event
translate-event
check-function
defevent
undefevent
event-actions
add-event
delete-event
describe-event-translations
add-timer
delete-timer
))
;; INPUT PROCESSING
;; Rather than pass around event parameters in long plists,
;; parameters are stuffed into this structure. For any one event,
;; most slots are undefined, and these are initialized to NIL.
;; Event structures are kept on a resource and re-used.
;; The only reason event is a class and not a structure is because
;; we want to use with-slots.
(defclass event ()
((key) ; Event key
(display) ; Display event was reported to
(contact) ; Contact the event is directed to
(character) ; character from code and state
(keysym) ; keysym from code and state
(plist :initform nil :type list) ; Place for extension data
;; The following are from the CLX event
(above-sibling) ; Used by :configure-notify :configure-request
(atom) ; Used by :property-notify
(border-width) ; Used by :create-notify :configure-notify :configure-request
(child) ; Used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify
(code) ; Used by :key-press :key-release :button-press :button-release
(colormap) ; Used by :colormap-notify
(sequence) ; Used by all except :keymap-notify
(configure-p) ; Used by :unmap-notify
(count) ; Used by :exposure :graphics-exposure :mapping-notify
(data) ; Used by :client-message :timer
(drawable) ; Used by :graphics-exposure :no-exposure
(event-window) ; Used by :destroy-notify :unmap-notify :map-notify :reparent-notify
; :configure-notify :gravity-notify :circulate-notify
(focus-p) ; Used by :enter-notify :leave-notify
(format) ; Used by :client-message
(height) ; Used by :exposure :graphics-exposure :create-notify :configure-notify
; :configure-request :resize-request
(hint-p) ; Used by :motion-notify
(installed-p) ; Used by :colormap-notify
(keymap) ; Used by :keymap-notify
(kind) ; Used by :enter-notify :leave-notify :focus-in :focus-out
(major) ; Used by :graphics-exposure :no-exposure
(minor) ; Used by :graphics-exposure :no-exposure
(mode) ; Used by :enter-notify :leave-notify :focus-in :focus-out
(name) ; Used by :timer
(new-p) ; Used by :colormap-notify
(override-redirect-p) ; Used by :create-notify :map-notify
; :reparent-notify :configure-notify
(parent) ; Used by :create-notify :map-request :reparent-notify :configure-request
; :circulate-notify :circulate-request
(place) ; Used by :circulate-notify :circulate-request
(property) ; Used by :selection-request :selection-notify
(requestor) ; Used by :selection-request
(root) ; Used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify
(root-x) ; Used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify
(root-y) ; Used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify
(same-screen-p) ; Used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify
(selection) ; Used by :selection-clear :selection-request :selection-notify
(send-event-p) ; Used by -all events-
(state) ; Used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify
; :visibility-notify :property-notify
(target) ; Used by :selection-request :selection-notify
(time) ; Used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify :property-notify
; :selection-clear :selection-request :selection-notify
(type) ; Used by :client-message
(width) ; Used by :exposure :graphics-exposure :create-notify :configure-notify
; :configure-request :resize-request
(window) ; Used by all events except :graphics-exposure :no-exposure :mapping-notify
(x) ; Used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify :exposure
; :graphics-exposure :create-notify :reparent-notify
; :configure-notify :configure-request :gravity-notify
(y) ; Used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify :exposure
; :graphics-exposure :create-notify :reparent-notify
; :configure-notify :configure-request :gravity-notify
)
(:documentation "CLUE event structure, one slot for every event value. No methods."))
(defmethod print-object ((instance event) stream)
#+lispm
(si:printing-random-object (instance stream)
(with-slots (key contact) instance
(format stream "Event ~a for ~a" key (and (typep contact 'contact) (contact-name contact)))))
#-lispm
(progn
(write-string "#<EVENT " stream)
(with-slots (key contact) instance
(princ key stream)
(when (typep contact 'contact)
(write-string " for " stream)
(princ (contact-name instance) stream)))
(write-char #\> stream)))
;;; PROCESS-NEXT-EVENT copies event data into an event structure. After the
;;; event is processed, its put back into *event-cache* to be re-used on the
;;; next event. This is done to reduce consing. Care is taken to shield the
;;; application progammer from the actual event structure to prevent saving the
;;; event structure in application data structures. If an application did this,
;;; the event would be destructively modified on subsequent events.
(defvar *event-cache* nil)
(defun allocate-event ()
;; Get an event structure, initializing all slots to NIL
(let ((event (or (xlib::atomic-pop *event-cache*)
(make-instance 'event))))
(with-slots (key display contact character keysym plist code state time event-window
root drawable window child parent root-x root-y x y
width height border-width override-redirect-p same-screen-p
configure-p hint-p kind mode keymap focus-p count major minor
above-sibling place atom selection requestor target property
colormap new-p installed-p format type data name send-event-p
)
(the event event)
(setf key nil
display nil ; Display event was reported to
contact nil ; Contact the event is directed to
character nil ; character from code and state
keysym nil ; keysym from code and state
;; The following are from the CLX event
code nil
state nil
time nil
event-window nil
root nil
drawable nil
window nil
child nil
parent nil
root-x nil
root-y nil
x nil
y nil
width nil
height nil
border-width nil
override-redirect-p nil
same-screen-p nil
configure-p nil
hint-p nil
kind nil
mode nil
keymap nil
focus-p nil
count nil
major nil
minor nil
above-sibling nil
place nil
atom nil
selection nil
requestor nil
target nil
property nil
colormap nil
new-p nil
installed-p nil
format nil
type nil
data nil
send-event-p nil
name nil
plist nil
))
event))
(defun deallocate-event (event)
;; Return an event to the cache, where it can be re-used.
(xlib::atomic-push event *event-cache*))
;;-----------------------------------------------------------------------------
;; MODES
;;; Applications may find it necessary to establish a special input
;;; "mode" in which the user is temporarily required to direct input
;;; to one or more specific contacts. In such a mode, user input
;;; events directed to other contacts are not handled normally, but
;;; instead are either ignored or acknowledged with some kind of
;;; warning.
(deftype mode-type () '(member :non-exclusive :exclusive :spring-loaded))
(defparameter *remap-events* '(:key-press :key-release :button-press :button-release)
"These events are sent to the most recent :spring-loaded contact on the mode-stack.")
(defparameter *restrict-events*
'(:motion-notify :enter-notify :leave-notify)
"These 'user' events are sent to the restrict-action of the first
:exclusive contact on the mode-stack")
(defparameter *sensitive-events*
'(:key-press :key-release :button-press :button-release
:motion-notify :enter-notify :leave-notify
:focus-in :focus-out)
"These 'user' events are ignored by an insensitive contact.")
;; Other events (NOT in *remap-events* or *restrict-events*) are handled normally
;;; When dispatching *restrict-events*, if the mode-stack is non-nil,
;;; the event is restricted as follows. For each entry of the
;;; mode-stack, if the event is for the contact on the stack, or one of
;;; its descendents, it is dispatched. When a stack-entry with
;;; :Exclusive or :Spring-Loaded MODE-TYPE is encountered, the search
;;; stops, and the event is sent to the RESTRICT-ACTION action of the
;;; mode contact with ARGS. If there are no :Exclusive or
;;; :Spring-Loaded contacts on the stack, the event is dispatched
;;; normally.
;;;
;;; When dispatching *remap-events*, if the mode-stack is non-nil, the
;;; event is sent (re-mapped) to the first :spring-loaded contact on the
;;; mode-stack. If there is no :spring-loaded contact, *remap-events*
;;; are handled like *restrict-events*
(defun add-mode (contact &optional (mode-type :non-exclusive) (action 'restrict) &rest args)
"Push CONTACT with (mode-type action . args) onto the mode-stack"
(declare (type contact contact)
(type mode-type mode-type)
(type symbol action)
(type list args))
(when (and (not (eq mode-type :non-exclusive))
(not (sensitive-p contact)))
(error "ADD-MODE on insensitive contact ~s" contact))
(push (list* contact mode-type action (copy-list args))
(display-mode-stack (contact-display contact))))
(defun delete-mode (contact)
"Pop CONTACT (and everything above CONTACT) off the mode-stack
Returns T when found and removed, else NIL"
(declare (type contact contact)
(values boolean))
(let* ((display (contact-display contact))
(mode-stack (display-mode-stack display)))
(when mode-stack
(do ((stack mode-stack (cdr stack)))
((endp stack)
;; If contact not found, check its children
;; This feature utilized when un-mapping the parent of a modal contact
(do ((stack mode-stack (cdr stack))
(found-p nil)
(result nil))
((endp stack)
(when found-p
(setf (display-mode-stack display) result)
t))
(when (ancestor-p contact (caar stack))
(setq found-p t
result stack))))
(when (eq contact (caar stack))
(setf (display-mode-stack display) (cdr stack))
(return t))))))
(defmacro with-mode ((contact &key (mode-type :exclusive)
(action 'ignore-action) args)
body-form &body cleanup-forms)
"While executing BODY-FORM, user events will only be delivered to CONTACT
and its children. Non-user events (e.g. exposure,property-notify, etc)
will be delivered normally. User events to other contacts will cause
the ACTION action for CONTACT's class to be invoked with ARGS. The
primary contact method for the default ACTION, ignore-action, beeps on
*remap-events*, and ignores all others.
WITH-MODE executes BODY-FORM within an Unwind-Protect. With-Mode
returns the value of its BODY-FORM, and executes CLEANUP-FORMS before
exiting. "
(let ((local-contact (gensym)))
`(let ((,local-contact ,contact))
(unwind-protect
(progn
(add-mode ,local-contact ,mode-type (function ,action) ,@args)
,body-form)
(delete-mode ,local-contact)
,@cleanup-forms))))
(defun contact-mode (contact)
"If contact is the descendent of a modal contact, return the modal contact, else NIL."
(let ((modes (display-mode-stack (contact-display contact))))
(if modes ;; No mode stack means EVERYTHING is in "on the stack"
(do ((p contact (contact-parent p)))
((null p) nil)
(dolist (mode modes)
(cond ((eq p (car mode))
(return-from contact-mode p))
((eq (cadr mode) :exclusive)
(return nil))))))))
(defun contact-super-mode (contact)
"If contact is the descendent of a modal contact, return the superior modal contact, else NIL."
(let ((modes (cluei::display-mode-stack (contact-display contact))))
(if modes ;; No mode stack means EVERYTHING is in "on the stack"
(do ((p contact (contact-parent p)))
((null p) nil)
(do ((mode modes (cdr mode))
(supermode nil))
((endp mode))
(when (eq p (caar mode))
(return-from contact-super-mode supermode))
(unless (eq (cadar mode) :non-exclusive)
(setq supermode (caar mode))))))))
(defmacro with-event-mode ((contact &rest translations) &body body)
"The given event TRANSLATIONS are defined for the CONTACT only within
the dynamic extent of the BODY. The TRANSLATIONS are processed before any
other previously-defined instance or class translations for CONTACT."
(let ((previous-actions (gensym))
(new-translations (gensym))
(translation (gensym))
(previous (gensym)))
`(let* ((,new-translations (list ,@translations))
(,previous-actions
;; Save any actions from previous instance translations for these event specs
(let (pa)
(dolist (,translation ,new-translations (nreverse pa))
(push (assoc (car (parse-event-spec ,translation))
(slot-value (the contact ,contact) 'event-translations)
:test #'equal)
pa)))))
;; Add modal translations
(dolist (,translation ,new-translations)
(apply #'add-event ,contact ,translation))
(unwind-protect
(progn
,@body)
;; Delete modal translations and restore any previous ones
(dolist (,translation ,new-translations)
(let ((,previous (pop ,previous-actions)))
(if ,previous
(apply #'add-event ,contact (first ,translation) ,previous)
(delete-event ,contact (first ,translation)))))))))
;;;-----------------------------------------------------------------------------
;;; Actions
;; Retained temporarily for compatibility purposes
(defmacro defaction (name lambda-list &body body)
"Define an action method. THIS MACRO IS NOW OBSOLETE. Just use defmethod."
(let (qualifier self)
;; Handle method qualifiers (:before or :after)
(when (atom lambda-list)
(setq qualifier (list lambda-list)
lambda-list (pop body)))
;; Get the first specialized parameter in the lambda-list
(dolist (arg lambda-list)
(when (member arg lambda-list-keywords) (return nil))
(when (consp arg)
(setf self (first arg))))
`(progn
(compiler-let (($contact$ ',self)) ; Hook for call-action
(defmethod ,name ,@qualifier ,lambda-list
,@body)))))
(defmacro with-event (slots &body body)
"Used within an action method to access event slots."
`(locally
(declare (special $event$))
(unless (boundp '$event$)
(error "WITH-EVENT used outside the dynamic extent of PROCESS-NEXT-EVENT."))
(with-slots ,slots (the event $event$) ,@body)))
(defmacro call-action (action &rest args)
"Used within DEFACTION to call another action. THIS MACRO IS NOW OBSOLETE. Replace
with a direct reference to the ACTION function."
(declare (special $contact$))
(unless (boundp '$contact$)
(error "CALL-ACTION used outside DEFACTION."))
`(,action ,$contact$ ,@args))
(proclaim '(inline call-action-internal))
(defun call-action-internal (contact action)
(if (consp action)
(apply (car action) contact (cdr action))
(funcall action contact)))
(defun add-before-action (display class action-name &rest args)
"Call the action named ACTION-NAME with ARGUMENTS before every event
on DISPLAY directed to a contact whose class is the same as
or superclass of the action class."
(let ((entry (list* class action-name (copy-list args))))
(setf (before-actions display)
(cons entry
(delete entry (before-actions display)
:count 1
:test #'equal))))
action-name)
(defun delete-before-action (display class action-name)
"Remove a before event-handler from display"
(setf (before-actions display)
(delete (cons class action-name)
(before-actions display)
:count 1
:test #'equal))
action-name)
;;;-----------------------------------------------------------------------------
;;; BUILT-IN ACTIONS
(defmethod inside-contact-p ((contact contact) x y)
"Returns T when X/Y (in contact coordinates) is inside CONTACT"
(with-slots ((contact-width width) (contact-height height)) (the contact contact)
(and (<= 0 x)
(< x contact-width)
(<= 0 y)
(< y contact-height))))
(defmethod perform-callback ((contact basic-contact) name &rest args)
;; WARNING: duplicates apply-callback code, instead of (eval (apply-callback...))
(let ((functions (callback-p contact name)))
(when functions
(let ((args (copy-list args)) ;Cons Alert!!
(*contact* contact))
(catch :abort-callback
(do* ((functions functions (rest functions))
(function (first functions) (first functions)))
((null (rest functions))
;; Return value(s) of last callback function
(apply (first function) (nconc args (rest function))))
(setf args (nconc args (rest function)))
(apply (first function) args)
(setf args (nbutlast args (length (rest function))))))))))
(defmethod apply-action ((contact basic-contact) function &rest args)
(declare (special *contact*))
(let ((*contact* contact))
(apply function args)))
(defmethod eval-action ((contact basic-contact) &rest forms)
(declare (special *contact*))
(let ((*contact* contact))
(dolist (form forms)
(eval form))))
(defmethod trace-action ((event-contact basic-contact) &rest exceptions)
(let (value result
(name (contact-name event-contact)))
(with-event ((event-key key))
(unless (member event-key exceptions :test #'eq)
(format *trace-output* "~%~s on ~a:"
event-key name)
(dolist (slot-name '(above-sibling atom border-width character child code colormap configure-p
count drawable event-window focus-p format height hint-p installed-p keymap
keysym kind major minor mode name new-p override-redirect-p parent place
plist property requestor selection send-event-p state target type width
window x y))
(when (and (setf value (slot-value (the event $event$) slot-name))
(not (eq value event-contact)))
(when (typep value 'contact) (setf value (contact-name value)))
(setf result (nconc result (list slot-name value)))))
(format *trace-output* "~{~<~%~20@t~1:; ~s ~s~>~^ ~}." result)))))
(defmethod describe-action ((event-contact basic-contact) &rest exceptions)
(with-event ((event-key key))
(unless (member event-key exceptions :test #'eq)
(format *trace-output* "~%~s on ~a:"
event-key (contact-name event-contact))
;; Loop over slots in alphabetical order
(dolist (slot-name '(above-sibling atom border-width character child code colormap configure-p
count drawable event-window focus-p format height hint-p installed-p keymap keysym
kind major minor mode name new-p override-redirect-p parent place plist
property requestor selection send-event-p state target type width window x y))
(let ((value (slot-value (the event $event$) slot-name)))
(when value
(when (typep value 'contact) (setf value (contact-name value)))
(format *trace-output* "~%~5t~20s~20s" slot-name value))))
(terpri *trace-output*))))
(defmethod ignore-action ((contact basic-contact))
;; Beep on *remap-events* else ignore
(with-event (key display)
(when (member key *remap-events* :test #'eq)
(bell display))))
(defmethod throw-action ((contact basic-contact) tag &optional value)
(throw tag value))
;;-----------------------------------------------------------------------------
;; EVENT-TRANSLATIONS
;;; Macros For defining event handlers at compile-time:
(defmacro defevent (class event-spec &rest actions)
"Add an event binding to the EVENT-TRANSLATIONS property of CLASS,
where it can be shared by all instances of CLASS."
(let ((event-parse (parse-event-spec (list* event-spec actions))))
`(progn
;; Generate compiler warnings for missing actions
#+ti ,@(mapcar #'(lambda (action)
(when (consp action) (setq action (car action)))
`(eval-when (compile)
(compiler:function-referenced
',action ',(intern (format nil "~s Event ~s" class event-spec)))))
(cdr event-parse))
(set-event-bindings ',class ',(car event-parse)
,@(mapcar #'(lambda (action) `(quote ,action)) (cdr event-parse))))))
(defun set-event-bindings (class event-spec &rest actions)
;; Internal function used by DEFEVENT
(setf (get class 'event-translations)
(cons (cons event-spec (copy-list actions))
(delete event-spec
(get class 'event-translations)
:key #'car :test #'equal :count 1))))
(defmacro undefevent (class event-spec &rest actions)
"Remove an event binding from the EVENT-TRANSLATIONS property of CLASS."
(declare (ignore actions))
(let ((event-spec (parse-event-spec (list event-spec))))
`(delete-event-bindings ',class ',(car event-spec))))
(defun delete-event-bindings (class event-spec)
;; Internal function used by UNDEFEVENT
(setf (get class 'event-translations)
(delete event-spec
(get class 'event-translations)
:key #'car :count 1 :test #'equal)))
;;; Functions for defining event handlers at run-time:
(defun event-actions (contact event-spec)
"Return the list of actions for event-spec."
(declare (values action-list))
;; Check instance translations
(let ((event-binding (car (parse-event-spec (list event-spec)))))
(cdr
(or
;; Instance translation?
(assoc event-binding
(slot-value (the contact contact) 'event-translations)
:test #'equal)
;; Class translation?
(assoc event-binding
(get (class-name-of contact) 'event-translations)
:test #'equal)
;; Superclass class translation?
(dolist (class (class-all-superclasses (class-name-of contact)))
(let ((actions (assoc event-binding
(get class 'event-translations)
:test #'equal)))
(when actions
(return actions))))))))
(defun add-event (contact event-spec &rest actions)
"Add EVENT-SPEC and ACTIONS to the event-translations for CONTACT."
(let ((event-binding (parse-event-spec (list* event-spec (copy-list actions)))))
(with-slots (event-mask event-translations) (the contact contact)
(let ((previous (assoc (car event-binding) event-translations :test #'equal)))
(if previous
(setf (cdr previous) (cdr event-binding))
(push event-binding event-translations)))
(when (realized-p contact)
(let ((new-mask (update-event-mask event-binding event-mask)))
(unless (= new-mask event-mask) ;; When modified
(setf event-mask new-mask)
(setf (window-event-mask contact) event-mask))))))
(values))
(defun delete-event (contact event-spec)
"Remove EVENT-SPEC from the event-translations for CONTACT."
(let ((event-binding (parse-event-spec (list event-spec))))
(with-slots (event-mask event-translations) (the contact contact)
;; Compute event mask without current event translations
(setf event-translations
(delete (car event-binding) event-translations
:key #'car :count 1
:test #'equal))
(when (realized-p contact)
;; Update the contact event mask
(let ((new-mask (compute-contact-event-mask contact))
(old-bit (update-event-mask event-binding 0)))
(when (zerop (logand new-mask old-bit)) ;; When modified
;; Only modify the event-mask bit for the event being deleted
(setf new-mask (logandc2 event-mask old-bit)
event-mask new-mask
(window-event-mask contact) new-mask))))))
(values))
;;;-----------------------------------------------------------------------------
;;; EVENT-PARSING
;; In X, there are event-NAMEs, which are used to specify which events are desired,
;; and event-KEYs, which are the names of specific events. This ALIST maps
;; event-KEYs to event-MASK's. This is used for automagicly creating the
;; event-name mask for window creation from the list of event-keys a contact is
;; interested in. If a third alist element is present, its a function to call
;; to compute the event-mask from the match parameters.
(defparameter *event-mask-alist*
'((:key-press #.(make-event-mask :key-press))
(:key-release #.(make-event-mask :key-release))
(:button-press #.(make-event-mask :button-press) button-press-mask)
(:button-release #.(make-event-mask :button-release) button-release-mask)
(:motion-notify #.(make-event-mask :pointer-motion) motion-event-mask)
(:enter-notify #.(make-event-mask :enter-window))
(:leave-notify #.(make-event-mask :leave-window))
(:focus-in #.(make-event-mask :focus-change))
(:focus-out #.(make-event-mask :focus-change))
(:keymap-notify #.(make-event-mask :keymap-state))
(:exposure #.(make-event-mask :exposure))
(:graphics-exposure)
(:no-exposure)
(:visibility-notify #.(make-event-mask :visibility-change))
(:create-notify) ; substructure-notify on parent
(:destroy-notify #.(make-event-mask :structure-notify)) ; or substructure-notify on parent
(:unmap-notify #.(make-event-mask :structure-notify)) ; or substructure-notify on parent
(:map-notify #.(make-event-mask :structure-notify)) ; or substructure-notify on parent
(:map-request) ; substructure-notify on parent
(:reparent-notify #.(make-event-mask :structure-notify)) ; or substructure-notify on parent
(:configure-notify #.(make-event-mask :structure-notify)) ; or substructure-notify on parent
(:gravity-notify #.(make-event-mask :structure-notify)) ; or substructure-notify on parent
(:resize-request #.(make-event-mask :resize-redirect))
(:configure-request) ; substructure-notify on parent
(:circulate-notify #.(make-event-mask :structure-notify)) ; or substructure-notify on parent
(:circulate-request) ; substructure-notify on parent
(:property-notify #.(make-event-mask :property-change))
(:selection-clear)
(:selection-request)
(:selection-notify)
(:colormap-notify #.(make-event-mask :colormap-change))
(:client-message)
(:mapping-notify)
(:timer)
))
(defmacro check-function (event-key)
"Return the check function for parsing the EVENT-KEY."
`(get ,event-key 'check))
(defun parse-event-spec (event-translation)
"Do error checking and canonicalization of an event translation."
(declare (values event-translations window-event-mask))
(cons (let ((event-spec (first event-translation)))
(typecase event-spec
(list
(let* ((key (car event-spec))
(real-key key)
(checker (check-function (car event-spec)))
(args nil))
(unless checker
(error "~s is not a known event keyword." (car event-spec) ))
(multiple-value-setq (args real-key)
(apply checker event-spec))
(unless real-key (setq real-key key))
(cons real-key args)))
(character
(cons :key-press (key-check :key-press event-spec)))
(otherwise
(unless (assoc event-spec *event-mask-alist* :test #'eq)
(error "~s is not a known event keyword." event-spec))
event-spec)))
(cdr event-translation)))
(defun update-event-mask (event-translation event-mask)
"Return the LOGIOR of EVENT-MASK with the event mask determined by EVENT-TRANSLATION."
(let* ((event-spec (car event-translation))
(event-key (if (consp event-spec) (car event-spec) event-spec))
(mask (cdr (assoc event-key *event-mask-alist* :test #'eq))))
(cond ((null mask) event-mask)
((atom event-spec) (logior event-mask (car mask)))
((cdr mask) (logior event-mask (apply (cadr mask) (cddr event-spec))))
(t (logior event-mask (car mask))))))
(defun compute-contact-event-mask (contact)
"Compute an event-mask from the event translations (class and instance) for CONTACT."
(declare (values mask32))
(let ((mask 0)
(class (class-name-of contact)))
;; Instance translations
(dolist (event (slot-value (the contact contact) 'event-translations))
(setq mask (update-event-mask event mask)))
;; Class translations
(dolist (event (get class 'event-translations))
(setq mask (update-event-mask event mask)))
;; Superclass translations
(dolist (class (class-all-superclasses class))
(dolist (event (get class 'event-translations))
(setq mask (update-event-mask event mask))))
mask))
;;;-----------------------------------------------------------------------------
;;; CHECK/MATCH functions
(defun encode-button-number (button)
(or (position button
#(:any :button-1 :button-2 :button-3 :button-4 :button-5))
(xlib::x-type-error
button 'button
"One of :Any :button-1 :button-2 :button-3 :button-4 :button-5")))
;; Alist associating modifier keys with modifier keysyms
(defvar *meta-modifier-alist*
'((:meta #.(keysym :left-meta) #.(keysym :right-meta))
(:super #.(keysym :left-super) #.(keysym :right-super))
(:hyper #.(keysym :left-hyper) #.(keysym :right-hyper))))
(defconstant meta-shift 16.) ;; Where to shift meta-modifier keystates
(defconstant mod-1-shift (position :mod-1 xlib::*state-mask-vector*))
(defconstant button-0-shift (1- (position :button-1 xlib::*state-mask-vector*)))
(defun get-display-modifier-translate (display &optional update-p)
;; Returns a table that translates meta-modifier bits
;; into mod1/mod2/mod3/mod4/mod5 modifier state bits.
(declare (type display display)
(type boolean update-p))
(or (and (not update-p) (display-modifier-translate display))
(let* ((mapping (xlib::get-display-modifier-mapping display))
(mod-length (length *meta-modifier-alist*))
(translate-length (ash 1 mod-length))
(display-translate (display-modifier-translate display))
(translate (or (and (>= (length display-translate) translate-length)
display-translate)
(make-array translate-length)))
(mod-vector (make-array mod-length)))
(xlib::declare-array simple-vector translate mod-vector)
(do* ((modifiers *meta-modifier-alist* (cdr modifiers))
(i 0 (1+ i))
(temp))
((endp modifiers))
(setf (aref mod-vector i)
(dolist (modifier (cdar modifiers) 0)
(when (setq temp (assoc modifier mapping :test #'eq))
(return (cdr temp))))))
(dotimes (i translate-length)
(let ((mask 0))
(dotimes (j mod-length)
(when (logbitp j i)
(setq mask (logior mask (aref mod-vector j)))))
(setf (aref translate i) mask)))
(setf (display-modifier-translate display) translate))))
(proclaim '(inline translate-meta-modifiers))
(defun translate-meta-modifiers (state translate)
;; Translate the meta/super/hyper modifiers in state to mod-1/mod-2/mod3/mod4/mod5 modifiers.
;; TRANSLATE is the result from GET-DISPLAY-MODIFIER-TRANSLATE
(logior (ldb (byte meta-shift 0) state)
(aref translate (ash state (- meta-shift)))))
(defun encode-clue-modifier-mask (modifiers)
;; Make a state-mask from modifiers
(declare (type (or mask16 state-mask-key (member :meta :super :hyper) list) modifiers)
(values mask16))
(typecase modifiers
(fixnum (ldb (byte meta-shift 0) modifiers))
(cons (let ((mask 0))
(dolist (modifier modifiers)
(logior mask (encode-clue-modifier-mask modifier)))
mask))
(otherwise
(let ((temp (position modifiers (the list *meta-modifier-alist*) :key #'car :test #'eq)))
(if temp
(ash 1 (+ temp meta-shift))
(make-state-mask modifiers))))))
(proclaim '(inline event-spec-match))
(defun event-spec-match (display state select event-state)
(let ((translate (get-display-modifier-translate display)))
(setq state (translate-meta-modifiers state translate)
select (translate-meta-modifiers select translate)))
; The modifiers common to select and state must be DOWN and
; The modifiers in select but not state must be UP
(and (= (logand state select) (logand event-state select))
; When there are modifiers in state that aren't in select
(or (zerop (logandc2 state select))
; At least one of them must be DOWN
(plusp (logand event-state (logandc2 state select)))))
; Modifiers that aren't in state or select are ignored
)
#| ;; event-spec-match implements the following relationships:
.-------------------------------.
| event-state 4 4 4 4 4 4 4 4 4|
|4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4|
|4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4|
|4 4 .-------------------. 4 4 4|
|4 4 | Select 1 1 1 1 1 | 4 4 4|
|4 4 | 1 1 1 1 1 1 1 1 1 | 4 4 4|
|4 4 | 1 .-----------. 1 | 4 4 4| This would look better in color
|4 4 | 1 | 2 2 2 2 2 | 1 | 4 4 4|
|4 4 | 1 | 2 2 2 2 2 | 1 | 4 4 4|
|4 4 | 1 | 2 2 2 2 2 | 1 | 4 4 4|
|4 4 `---+-----------+---' 4 4 4|
|4 4 4 4 | 3 3 3 3 3 | 4 4 4 4 4|
|4 4 4 4 | 3 3 3 3 3 | 4 4 4 4 4|
|4 4 4 4 | State 3 3 | 4 4 4 4 4|
|4 4 4 4 `-----------' 4 4 4 4 4|
|4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4|
|4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4|
`-------------------------------'
1. Modifiers in select but not state ; Must be UP in the event
2. Modifiers both in state and select ; Must be DOWN in the event
3. Modifiers in state but not select ; If any, at least one must be down
4. Modifiers in neither select or state ; are ignored
|#
(defun key-check (event-key &optional char state select)
;; Returns the canonical form of the key (i.e. one that may speed up
;; the matching operation)
(when (not (typep char '(or card16 character (member :any))))
(error "parameter in ~s must be a CHARACTER, CARD16 or :ANY"
(list event-key char state select)))
(let* ((modifiers
(cond ((null state) (setq select 0)) ;; Default is :none
((typep state 'fixnum) state) ;; mask16
((eq state :none) 0)
((eq state :any) (setq select 0))
((consp state)
(encode-clue-modifier-mask state))
(t (encode-clue-modifier-mask state))))
(mask
(cond ((null select) #xffff) ;; Default is all
((typep select 'fixnum) select) ;; mask16
((eq select :all) (setq select #xffff))
((eq select :same) modifiers)
((consp select) (encode-clue-modifier-mask select))
(t (encode-clue-modifier-mask select)))))
(list 'key-match char modifiers mask)))
(defun key-match (event spec-code spec-state spec-select)
;; Returns T if EVENT-SPEC matches EVENT
(with-slots (display character state keysym) (the event event)
(and (event-spec-match display spec-state spec-select state)
(cond
((characterp spec-code) (eql spec-code character))
((eq spec-code :any) t)
(t (eql spec-code keysym))))))
(defun button-check (event-key &optional code state select)
(let* ((options nil)
(button (encode-button-number (or code :any)))
(modifiers
(cond ((null state) (setq select 0)) ;; Default is :none
((typep state 'fixnum) state) ;; mask16
((eq state :none) 0)
((eq state :any) (setq select 0))
((eq state :test)
(push :test options)
(setq select 0))
((eq state :single-click)
(push :single-click options)
(setq select 0))
((eq state :double-click)
(push :double-click options)
(setq select 0))
((consp state)
(cond ((member :single-click state)
(push :single-click options)
(unless (setq state (remove :single-click state))
(setq select 0)))
((member :double-click state)
(push :double-click options)
(unless (setq state (remove :double-click state))
(setq select 0))))
(encode-clue-modifier-mask state))
(t (encode-clue-modifier-mask state))))
(mask
(cond ((null select) modifiers) ;; Default is same
((typep select 'fixnum) select) ;; mask16
((eq select :same) modifiers)
((eq select :all) (setq select #xffff))
((consp select) (encode-clue-modifier-mask select))
(t (encode-clue-modifier-mask select))))
(predicate (if (eq event-key :button-press) 'button-press-match 'button-release-match)))
(list* predicate button modifiers mask options)))
(defun button-press-mask (button state select &optional option)
(declare (ignore button state select))
(if option
#.(make-event-mask :button-press :button-release)
#.(make-event-mask :button-press)))
(defun button-release-mask (button state select &optional option)
(declare (ignore button state select))
(if option
#.(make-event-mask :button-press :button-release)
#.(make-event-mask :button-release)))
(defun button-press-match (event button state select &optional option)
(with-slots ((event-code code)
(event-state state)
display key plist time x y)
(the event event)
(let* ((code event-code)
(mask (ash 1 (+ code button-0-shift))))
(and
(or (zerop button) ; Zero button means "any" button
(= button code))
(event-spec-match display state select
(logandc2 event-state mask)) ; Clear state bit for current button
(case option
(:single-click
(= (click-lookahead display 1 2 time (logior event-state mask) x y) 2))
(:double-click
(= (click-lookahead display 1 4 time (logior event-state mask) x y) 4))
(otherwise t))))))
(defun button-release-match (event button state select &optional option)
(with-slots ((event-code code)
(event-state state)
key display plist time x y)
(the event event)
(let* ((code event-code)
(mask (ash 1 (+ code button-0-shift))))
(and
(or (zerop button) ; Zero button means "any" button
(= button code))
(event-spec-match display state select (logandc2 event-state mask)) ; Clear state bit for current button
(case option
(:single-click
(= (click-lookahead display 2 2 time event-state x y) 2))
(:double-click
(= (click-lookahead display 2 4 time event-state x y) 4))
(otherwise t))))))
(defconstant all-button-mask (make-state-mask :button-1 :button-2 :button-3 :button-4 :button-5))
(defun motion-check (event-key &optional state select)
(declare (ignore event-key))
(let* ((modifiers
(cond ((null state) (setq select 0)) ;; Default is :none
((typep state 'fixnum) state) ;; mask16
((eq state :none) 0)
((eq state :any) (setq select 0) all-button-mask)
((consp state)
(encode-clue-modifier-mask state))
(t (encode-clue-modifier-mask state))))
(mask
(cond ((null select) #xffff) ;; Default is all
((typep select 'fixnum) select) ;; mask16
((eq select :all) (setq select #xffff))
((eq select :same) modifiers)
((consp select) (encode-clue-modifier-mask select))
(t (encode-clue-modifier-mask select)))))
(list 'motion-match modifiers mask)))
(defun motion-match (event state select)
(with-slots (display) (the event event)
(or (eq state :any)
(event-spec-match display state select (slot-value (the event event) 'state)))))
(defun motion-event-mask (state select)
(if (= all-button-mask (logand (logior state select) all-button-mask))
#.(make-event-mask :button-motion)
(let ((mask (logand state select all-button-mask)))
(when (zerop mask)
(setq mask #.(make-event-mask :pointer-motion)))
mask)))
(eval-when (compile) ;; motion-event-mask makes the following assumption:
(assert (and (= (make-event-mask :button-1-motion) (make-state-mask :button-1))
(= (make-event-mask :button-2-motion) (make-state-mask :button-2))
(= (make-event-mask :button-3-motion) (make-state-mask :button-3))
(= (make-event-mask :button-4-motion) (make-state-mask :button-4))
(= (make-event-mask :button-5-motion) (make-state-mask :button-5)))
() "Button event-mask is shifted relative to button state-mask"))
(defun enter-leave-check (event-key &rest kinds)
(dolist (kind kinds)
(unless (member kind '(:ancestor :virtual :inferior :nonlinear :nonlinear-virtual))
(error "~s isn't an enter/leave kind for ~s" kind (cons event-key kinds))))
(list 'enter-leave-match kinds))
(defun enter-leave-match (event kinds)
(member (slot-value (the event event) 'kind) kinds :test #'eq))
(setf (check-function :key-press) 'key-check)
(setf (check-function :key-release) 'key-check)
(setf (check-function :button-press) 'button-check)
(setf (check-function :button-release) 'button-check)
(setf (check-function :motion-notify) 'motion-check)
(setf (check-function :enter-notify) 'enter-leave-check)
(setf (check-function :leave-notify) 'enter-leave-check)
(defun key-up-check (event-key &rest parms)
(declare (ignore event-key))
;; Convert (:up ...) to (:key-press ...)
(values (apply #'key-check :key-release parms)
:key-release))
(setf (check-function :up) #'key-up-check)
(defun client-message-check (event-key type &rest accessors)
(declare (ignore event-key))
(assert (typep type 'xatom) () "~s must be an X atom." type)
(do* ((accessors accessors (cddr accessors))
(function (first accessors) (first accessors))
(rest (rest accessors) (rest accessors)))
((null accessors))
(assert rest () "No value given for ~s accessor." function))
(values (list* 'client-message-match
(intern (string type) 'keyword)
accessors)
:client-message))
(defun client-message-match (event type &rest accessors)
(with-slots ((event-type type) (event-data data) (event-display display)) event
;; Bind display for use in accessor functions
(let ((*event-display* event-display))
(declare (special *event-display*))
(and (eq type event-type)
(do* ((accessors accessors (cddr accessors))
(function (first accessors) (first accessors))
(value (second accessors) (second accessors)))
((null accessors) t)
(unless (equal value (funcall function event-data))
(return nil)))))))
(setf (check-function :client-message) #'client-message-check)
(defun wm-protocol-check (event-key &rest accessors)
(apply 'client-message-check
:client-message :wm_protocols
'wm-message-protocol-atom event-key
accessors))
(setf (check-function :wm_take_focus) #'wm-protocol-check)
(setf (check-function :wm_save_yourself) #'wm-protocol-check)
(setf (check-function :wm_delete_window) #'wm-protocol-check)
;;;-----------------------------------------------------------------------------
;;; DOUBLE-CLICK events
(defun click-lookahead (display count max first-time state first-x first-y)
(declare (type card8 count)) ;; even when the button is UP, odd when DOWN
(let* ((multipress-verify-p (display-multipress-verify-p display))
(multipress-delay-limit (display-multipress-delay-limit display))
(timeout (/ multipress-delay-limit 1000.0))
(distance-limit 5))
(flet ((get-result (count timeoutp)
;; If the result from GET-RESULT is NIL, all lookahead events
;; remain on the event queue, otherwise the events are removed,
;; and the result from GET-RESULT is returned.
(if (or (evenp count) ; Hold events only occur on timeout
timeoutp)
count
0)))
(loop
(let*
((timeout-p t)
(result
(block result
;; When succeeding, we want to "eat" the events.
;; When failing, we want to leave events on the event queue.
;; We're careful to return non-nil from event-case only on success.
;; On failure, we return-from result, which leaves events on the queue.
;; the timeout-p hair is to detect the difference between failure and timeout.
(event-case (display :timeout timeout :force-output-p nil)
((motion-notify) (x y) ; Fail when pointer moves more than a jiggle
(setq timeout-p nil)
(when (> (+ (abs (- x first-x)) (abs (- y first-y))) distance-limit)
(return-from result (get-result count nil))))
((enter-notify leave-notify) () ; Fail when pointer moves to a new window
(setq timeout-p nil)
(return-from result (get-result count nil)))
(button-press (time (state event-state) code)
(setq timeout-p nil)
(cond ((>= count max) (return-from result :count))
((> time (+ first-time multipress-delay-limit))
(return-from result :timeout))
((or (oddp count)
(not (= state (logior event-state (ash 1 (+ code button-0-shift))))))
(return-from result (get-result count nil)))
(t (let ((result (click-lookahead display (1+ count) max
time state first-x first-y)))
(if (plusp result)
result
(if (plusp (setq result (get-result count nil)))
(return-from result result)
nil ;; else fall-through returning NIL
))))))
(button-release (time (state event-state))
(setq timeout-p nil)
(cond ((>= count max) (return-from result :count))
((> time (+ first-time multipress-delay-limit))
(return-from result :timeout))
((or (evenp count)
(not (= state event-state)))
(return-from result (get-result count nil)))
(t (let ((result (click-lookahead display (1+ count) max
time state first-x first-y)))
(if (plusp result)
result
(if (plusp (setq result (get-result count nil)))
(return-from result result)
nil ;; else fall-through returning NIL
))))))))))
(if timeout-p
;; event-case timed out
(if (or (zerop timeout)
(not multipress-verify-p))
(return (get-result count :local-timeout))
(progn
;; Verify timeout with a server round-trip and event-queue recheck
(display-finish-output display)
(setq timeout 0)))
;; Else exit loop with result
(return (case result
(:timeout (get-result (1- count) :timeout))
(:count 0)
(nil 0)
(otherwise result)))))))))
;;;-----------------------------------------------------------------------------
;;; EVENT-PROCESSING
(defun process-all-events (display)
"Process all pending events"
(loop
(xlib:display-finish-output display)
(let ((n-events (xlib:event-listen display)))
(if n-events
(dotimes (i n-events)
(process-next-event display))
;; Return when no events are queued after event-listen
(return nil)))))
(defun process-next-event (display &optional timeout)
"Process one event."
(declare (type display display) ; The display (from initialize-clue)
(type (or null number) timeout) ; optional timeout in seconds
(values boolean)) ; Returns NIL only if timeout exceeded
;; Ensure consistent contact states
(update-state display)
(internal-process-next-event display timeout))
(defun internal-process-next-event (display &optional timeout)
"Process one event."
(declare (type display display) ; The display (from initialize-clue)
(type (or null number) timeout) ; optional timeout in seconds
(values boolean)) ; Returns NIL only if timeout exceeded
(let*
(;; Process any timers that have expired
(interval-until-next-timer (execute-timers display))
;; Compute true timeout
(wait-for-timer-p (when (or (null timeout)
(and interval-until-next-timer
(< interval-until-next-timer timeout)))
interval-until-next-timer))
(event (allocate-event))
(result nil))
(setf (slot-value (the event event) 'display) display)
(macrolet ((set-event (&rest parameters)
`(progn ,@(mapcar #'(lambda (parm)
`(setf (slot-value (the event event) ',parm) ,parm))
parameters)))
(dispatch (contact)
`(progn
(dispatch-event event event-key send-event-p sequence ,contact)
t)))
;; Wait for an event, copy info into the EVENT structure then call DISPATCH-EVENT
(setf
result
(or
(xlib:event-cond (display :timeout (or wait-for-timer-p timeout)
:force-output-p t
:discard-p t)
((:key-press :key-release :button-press :button-release)
(code time root window child root-x root-y x y
state same-screen-p event-key sequence send-event-p) t
(set-event code time root window child root-x root-y x y
state same-screen-p)
(dispatch window))
(:motion-notify
(hint-p time root window child root-x root-y x y
state same-screen-p event-key sequence send-event-p) t
(set-event hint-p time root window child root-x root-y x y
state same-screen-p)
(dispatch window))
((:enter-notify :leave-notify)
(kind time root window child root-x root-y x y
state mode focus-p same-screen-p event-key sequence send-event-p) t
(set-event kind time root window child root-x root-y x y
state mode focus-p same-screen-p)
(dispatch window))
((:focus-in :focus-out)
(kind window mode event-key sequence send-event-p) t
(set-event kind window mode)
(dispatch window))
(:exposure
(window x y width height count event-key sequence send-event-p) t
(set-event window x y width height count)
(dispatch window))
(:graphics-exposure
(drawable x y width height count major minor event-key sequence send-event-p) t
(set-event drawable x y width height count major minor)
(dispatch drawable))
(:no-exposure
(drawable major minor event-key sequence send-event-p) t
(set-event drawable major minor)
(dispatch drawable))
(:visibility-notify
(window state event-key sequence send-event-p) t
(set-event window state)
(dispatch window))
(:create-notify
(parent window x y width height border-width
override-redirect-p event-key sequence send-event-p) t
(set-event parent window x y width height border-width
override-redirect-p)
(dispatch parent))
(:destroy-notify
(event-window window event-key sequence send-event-p) t
(set-event event-window window)
(dispatch event-window))
(:unmap-notify
(event-window window configure-p event-key sequence send-event-p) t
(set-event event-window window configure-p)
(dispatch event-window))
(:map-notify
(event-window window override-redirect-p event-key sequence send-event-p) t
(set-event event-window window override-redirect-p)
(dispatch event-window))
(:map-request
(parent window event-key sequence send-event-p) t
(set-event parent window)
(dispatch parent))
(:reparent-notify
(event-window window parent x y override-redirect-p event-key sequence send-event-p) t
(set-event event-window window parent x y override-redirect-p)
(dispatch event-window))
(:configure-notify
(event-window window above-sibling x y width height border-width
override-redirect-p event-key sequence send-event-p) t
(set-event event-window window above-sibling x y width height
border-width override-redirect-p)
(dispatch event-window))
(:configure-request
(parent window above-sibling x y width height border-width event-key sequence send-event-p) t
(set-event parent window above-sibling x y width height border-width)
(dispatch parent))
(:gravity-notify
(event-window window x y event-key sequence send-event-p) t
(set-event event-window window x y)
(dispatch event-window))
(:resize-request
(window width height event-key sequence send-event-p) t
(set-event window width height)
(dispatch window))
(:circulate-notify
(event-window window parent place event-key sequence send-event-p) t
(set-event event-window window parent place)
(dispatch event-window))
(:circulate-request
(parent window place event-key sequence send-event-p) t
(set-event parent window place)
(dispatch parent))
(:property-notify
(window atom time state event-key sequence send-event-p) t
(set-event window atom time state)
(dispatch window))
(:selection-clear
(time window selection event-key sequence send-event-p) t
(set-event time window selection)
(dispatch window))
(:selection-request
(time window requestor selection target property event-key sequence send-event-p) t
(set-event time window requestor selection target property)
(dispatch window))
(:selection-notify
(time window selection target property event-key sequence send-event-p) t
(set-event time window selection target property)
(dispatch window))
(:colormap-notify
(window colormap new-p installed-p event-key sequence send-event-p) t
(set-event window colormap new-p installed-p)
(dispatch window))
(:client-message
(format window type data event-key sequence send-event-p) t
(set-event format window type data)
(dispatch window))
(:keymap-notify ; Special case
(keymap event-key send-event-p) t
(set-event keymap) ; keymap-notify doesn't have an associated window.
(let ((sequence 0))
(dispatch (display-root display)))) ; Send keymap-notify events to the root.
(:mapping-notify ; Special case
(request start count) t
(mapping-notify display request start count)
(when (eq request :modifier) ; Update the modifier mapping translate table
(get-display-modifier-translate display :update))
t))
;; No event read -- return true (i.e. no timeout) if we now have a timer ready
(when wait-for-timer-p t))))
;; We could add an unwind protect to ensure that the event is always
;; deallocated (process-next-event is sometimes thrown out of).
;; However, we judge that an unwind-protect all the time is more
;; expensive than garbage collecting an event structure some of the
;; time.
(deallocate-event event)
result))
(defun dispatch-event (event event-key send-event-p sequence contact)
;; Called from PROCESS-NEXT-EVENT to filter events and call event handlers.
(declare (inline sensitive-p))
(with-slots ((event_key key)
(event-sequence sequence)
(event-send-event-p send-event-p)
(event-contact contact)) (the event event)
(setf event_key event-key
event-send-event-p send-event-p
event-sequence sequence
event-contact contact))
;;
;; Check for destroyed or invalid event-windows
;;
(if (not (typep contact 'basic-contact))
;; Not a contact!! Let the default root contact handle the event
(handle-event (display-root (drawable-display contact)) event)
(if (destroyed-p contact)
;; Destroyed-contact!
(when (eq event-key :destroy-notify)
(destroy-finish contact))
;; Bind event for reference within with-event forms
(let (($event$ event))
(declare (special $event$))
;;
;; Do key translation
;;
(when (or (eq event-key :key-press)
(eq event-key :key-release))
(with-slots (keysym character display code state) (the event event)
(let ((keysym-index (default-keysym-index display code state)))
(setf keysym (keycode->keysym display code keysym-index)
character (keycode->character display code state :keysym-index keysym-index)))))
;;
;; Call the before event handlers
;;
(let ((actions (before-actions (contact-display contact))))
(when actions
(let ((class (class-name-of contact)))
(dolist (before-action actions)
(when (subtypep class (car before-action))
(call-action-internal contact (cdr before-action)))))))
;;
;; Handle insensitive contacts
;;
(when (and (member event-key *sensitive-events* :test #'EQ)
(not (sensitive-p contact)))
(return-from dispatch-event nil))
;;
;; Handle modes
;;
(let ((modes (display-mode-stack (contact-display contact))))
(when (and modes (not (contact-mode contact)))
(when
(or (member event-key *restrict-events* :test #'eq)
(and (member event-key *remap-events* :test #'eq)
(dolist (mode modes t) ;; Search for first :spring-loaded mode
(when (eq (second mode) :spring-loaded)
(format t "~%Remapping ~s from ~s to ~s" event-key contact (first mode)) ;; *** DEBUG ***
(setq contact (first mode)) ;; Remap contact
(return nil)))))
;; Call mode action on for first :exclusive or :spring-loaded mode
(dolist (mode modes)
(unless (eq (second mode) :non-exclusive)
(call-action-internal (first mode) (cddr mode))
;; quit
(return-from dispatch-event nil))))))
;;
;; Handle event compression
;;
(with-slots ((contact-compress-motion compress-motion)
(contact-compress-exposures compress-exposures))
(the contact contact)
(case event-key
(:exposure ; Check for exposure compression
(when (and (eq contact-compress-exposures :on)
(plusp (slot-value (the event event) 'count)))
(return-from dispatch-event nil)))
(:motion-notify ; Check for motion compression
(when (eq contact-compress-motion :on)
(let ((count 0))
;; Count consecutive :motion-notify's currently in queue
(event-case ((contact-display contact) :peek-p t :timeout 0)
(:motion-notify (window)
(not (and (eq window contact) (incf count))))
(otherwise () t))
(when (plusp count)
;; Remove all but last and quit immediately
(do () ((zerop (decf count)))
(event-case ((contact-display contact) :timeout 0)
(otherwise () t)))
(return-from dispatch-event nil)))))))
;;
;; Handle event translations
;;
(handle-event contact event)))))
(defmethod handle-event ((contact basic-contact) (event event))
"Do event/callback translation based on the event-translations slot."
(declare (type contact contact)
(type event event))
;;
;; Handle universal events
;;
(when (eq :exposure (slot-value (the event event) 'key))
(with-slots (x y width height) (the event event)
(display contact x y width height)))
;; The following "universal event" is obsolete -- use shells for top-level windows
; (:configure-notify
; ;; A contact's x/y/width/height/border-width get updated immediately when
; ;; changing geometry. Top-level windows however, have their geometry
; ;; arbitrated by the window-manager. It probably doesn't make sense for
; ;; a non-top-level contact to select structure-notify. Because CLUE allows
; ;; any contact to be top-level, CLUE automatically selects structure-notify
; ;; for top-level contracts, and we set the size/position here.
; ;; If non-top-level contacts select structure-notify, we let them handle it
; ;; themselves.
; ;;
; ;; This is inadequate. The geometry manager for the
; ;; root should be used instead, waiting for the configure-notify,
; ;; and returning an appropriate successs-p parameter.
; ;;
; (with-slots (x y width height border-width window) (the event event)
; (when (and (eq window contact) (top-level-p contact))
; (without-requests contact
; (move contact x y)
; (resize contact width height border-width)))))
;;
;; Translate event and perform contact actions
;;
(dolist (action (translate-event contact event))
(call-action-internal contact action))
t)
(defun translate-event (contact event)
"Returns the actions for the first event-translation matching EVENT"
(declare (type contact contact)
(type event event))
(labels ((find-translation (event event-key translations)
(dolist (event-binding translations)
(let ((event-spec (car event-binding)))
(when (if (atom event-spec)
;; Simple EQ test when event spec is an atom
(eq event-key event-spec)
;; When event spec is a list, and
;; the car of the list is EQ to the event, and
;; the matcher function returns T
(and (eq event-key (car event-spec))
(apply (cadr event-spec) event (cddr event-spec))))
(return event-binding))))))
(let ((key (slot-value (the event event) 'key))
class)
(cdr
(or
;; Instance translations
(find-translation event key (slot-value (the basic-contact contact) 'event-translations))
;; Immediate class translations
(find-translation event key (get (setq class (class-name-of contact)) 'event-translations))
;; Superclass class translations
(dolist (class (class-all-superclasses class))
(let ((translation (find-translation event key (get class 'event-translations))))
(when translation (return translation)))))))))
(defmethod translate-key ((contact contact) event)
;; Find a translation for :key-press event EVENT which
;; was originally sent to CONTACT.
(let* ((parent (contact-parent contact))
(siblings (and parent (composite-children parent)))
actions)
(or ;; Check for handled by a sibling
(dolist (sibling siblings)
(unless (eq sibling contact)
(when (setq actions (translate-event sibling event))
(setf (slot-value (the event event) 'contact) sibling)
(dolist (action actions t)
(call-action-internal sibling action))
(return t))))
;; If not handled by a sibling of contact, check the parent
(when (and parent
(setq actions (translate-key parent event)))
(setf (slot-value (the event event) 'contact) parent)
(dolist (action actions t)
(call-action-internal parent action)))
;; Not handled by parent, recurse up to the parent
(translate-key parent contact))))
;;-----------------------------------------------------------------------------
;; TIMERS
(defstruct timer
name
time
interval
contact
data)
(defun add-timer (contact name interval &optional data)
"Send a :timer event to CONTACT every INTERVAL seconds passing DATA
The timer will be named NAME. The event is passed DATA NAME CONTACT and DISPLAY"
;; Timers are automatically removed when CONTACT is destroyed
(declare (type contact contact)
(type number interval) ;; in seconds
(values timer))
(delete-timer contact name)
(insert-timer (make-timer
:name name
:interval (* interval internal-time-units-per-second)
:contact contact
:data data))
name)
;; Internal function
(defun insert-timer (timer)
;; Insert timer into its timer-queue
(let* ((display (contact-display (timer-contact timer)))
(queue (timer-queue display))
(interval (timer-interval timer))
(time (+ interval (get-internal-real-time))))
(setf (timer-time timer) time)
;; Insert in order of execution (youngest first)
(if (or (null queue) (< time (timer-time (first queue))))
(push timer (timer-queue display))
(loop
(when (or (null (cdr queue))
(< time (timer-time (cadr queue))))
(return (setf (cdr queue) (cons timer (cdr queue)))))
(pop queue)))
timer))
(defun delete-timer (contact &optional timer-name)
"Remove timer named TIMER-NAME from CONTACT
If timer-name is NIL, remove ALL timers from CONTACT.
Returns NIL when timer not found, else T."
(let* ((display (contact-display contact))
(timer-queue (timer-queue display))
(deletedp nil))
(dolist (timer timer-queue)
(when (and (eq (timer-contact timer) contact)
(or (null timer-name)
(equal (timer-name timer) timer-name)))
(setq deletedp t)
(setf (timer-queue display)
(delete timer timer-queue :test #'eq :count 1))
(when timer-name
(return t))))
;; Return T when timers deleted
deletedp))
(defun execute-timers (display)
"Execute all timers whose time has come, returning the time (in seconds)
before the next timer executes for DISPLAY"
(loop
(let ((next-timer (car (timer-queue display))))
(unless next-timer
;; No timers active
(return nil))
(let ((next-time (timer-time next-timer)))
(when (> next-time (get-internal-real-time))
;; Return time interval before next timer fires
(return
(/ (- next-time (get-internal-real-time))
#.(float internal-time-units-per-second)))))
;; Reinsert timer for next firing
(pop (timer-queue display)) ;; Warning: If an abort happens here, There's a short
(insert-timer next-timer) ;; interval where a timer may be lost.
;; Dispatch a :timer event
(let ((event (allocate-event)))
(with-slots ((event-display display)
name data) (the event event)
(setf event-display display
name (timer-name next-timer)
data (timer-data next-timer)))
(dispatch-event event :timer nil 0 (timer-contact next-timer))
(deallocate-event event)))))
;;;-----------------------------------------------------------------------------
;;; Utility functions
(defun describe-event-translations (contact &optional (stream *standard-output*))
"Print the event translations for CONTACT
If contact is a contact class name, print the event translations
for that contact class."
(flet ((print-event (class event stream)
(format stream "~%From ~20a ~s" class (car event))
(dolist (action (cdr event))
(write-char #\space stream)
(prin1 action stream))))
(let ((class (if (symbolp contact)
contact
(class-name-of contact)))
(translations (and (typep contact 'contact)
(slot-value (the basic-contact contact) 'event-translations))))
;; Print event-translations for the contact
(dolist (event translations)
(print-event contact event stream))
;; Print event-translations for the contact's class
(dolist (event (get class 'event-translations))
(unless (assoc (car event) translations :test #'equal)
(print-event class event stream)
(push event translations)))
;; Print event-translations for the contact's superclasses
(dolist (class (class-all-superclasses class))
(dolist (event (get class 'event-translations))
(unless (assoc (car event) translations :test #'equal)
(print-event class event stream)
(push event translations)))))))